Developer CD Series 1994…tember: Reference Library/Dev.CD Sep 94.toast/Periodicals/develop/develop Issue 11/develop 11 code/The NetWork Project/NetWork Programmer's Stuff/NetWorkLookup.p

Text File | 1992-07-15 | 14.7 KB | 521 lines | [TEXT/MPS ]

{ Copyright 1989,90,91 The NetWork Project, StatLab Heidelberg.
  Copyright 1989,90,91 Joachim Lindenberg, Karlsruhe,
                       Günther Sawitzki, Heidelberg. All rights reserved. }

{ This library does not support code without an A5 world. If you want to use
  NetWork from other code (non application, non tool), you´ll have to use
  control calls to the driver directly. Contact us if you need help with that.

  The library uses a call to NetWork Processor to find out whether this process
  is already known to NetWork. If it is, it is assumed to be launched by NetWork
  by means of a message or idle time launch, and the type and signature are confirmed.
  If it is not known, the process is registered using the default type and the
  application´s signature. The default type is pMaster unless you set pDefault to
  something different. It is allowed to use pSlave or pLocal even if not launched
  automatically, and the process will be subject to the rules of slave/local
  processes in that case.
}

{$IFC UNDEFINED UsingIncludes}
{$SETC UsingIncludes := false}
{$ENDC}

unit NetWorkLookup;

interface

{ a star indicates that NetWork depends on these units, other comments indicate which unit
  requires the inclusion of this unit. Tripple stars mark the units that are required
  by the interface part of NetWork. If you use NetWork, but don´t use these units prior
  to NetWork, NetWork will automatically include them. Note that conscious use of uses
  will speed your compiles considerably. }

uses    Types {***}, FixMath {Packages}, QuickDraw {***lots of other units***},
        Events {*}, OSUtils {***}, SegLoad {Files}, Files {Devices, StandardFile/Packages}, Devices {*},
        Errors {*}, Memory {*}, Resources {*},
        Packages {*}, SysEqu {*}, Traps {*},
        ToolUtils {NetWorkLookup}, AppleTalk {NetWorkLookup},
        NetWork;

{$IFC UNDEFINED UsingNetWorkLookup}
{$SETC UsingNetWorkLookup:=true}

{$I+}
{$SETC NetWorkLookupIncludes:=UsingIncludes}
{$SETC UsingIncludes:=true}

{$IFC UNDEFINED UsingTypes}
{$I $$SHELL(PInterfaces)Types.p}
{$ENDC}

{$IFC UNDEFINED UsingOSUtils}
{$I $$SHELL(PInterfaces)OSUtils.p}
{$ENDC}

{$IFC UNDEFINED UsingAppletalk}
{$I $$SHELL(PInterfaces)AppleTalk.p}
{$ENDC}

{$IFC UNDEFINED UsingNetWorkUtilities}
{$I $$SHELL(NetWorkIncludes)NetWorkUtilities.p}
{$ENDC}

{ use "pascal -d NlServer=false" if you don´t want to register your own names }

{$IFC Undefined NlServer}
{$SETC NlServer:=true}
{$ENDC}

{ use "pascal -d NlClient=false" if you don´t want to look for other programs }

{$IFC Undefined NlClient}
{$SETC NlClient:=true}
{$ENDC}

{    =============================================================    }

{    name lookup - identication of possible partners }

const
    nlVersion    = -31100;    { -- no appletalk version 48 or higher, could be removed }
    nlTaskErr    = -31103;     { -- routines called in wrong order }
    nlNotFound    = -31104;     { -- used internally }
    nlDupReg    = -31105;     { -- called NlRegister twice }
    nlNoReg        = -31106;     { -- called NlDeregister without NlRegister }
    nlAtkOffErr = -31108;    { -- appletalk off, cannot use function }

function NlNode : longint;

{$IFC NlClient}

{    defaults to '=:Network Processor@*' }

function NlSetSearch (NlName, NlType, NlZone : Str32) : OSErr;

{    start/stop of NL task }

function NlStart : OSErr;
function NlStop : OSErr;

function NlTask : OSErr;        { call this function periodically }
function NlGetSleep : longint;    { time that may elapse until next call to NlTask  }

function NlCount : integer;        { or OSErr, if error, NlCount returns the number of partners found. }
function NLActive (who:longint) : boolean;    { is who still on the list ? }
function NLRandom : longint;    { any partner. returns 0 on error.}
function NLNext(after:longint) : longint;    { next partner. NLNext(0) returns first. returns 0 on error. }

{$ENDC}

{$IFC NlServer}

{    register a server, pass '' to use choosername, only one entity can be registered }

function NlRegister (NlName, NlType : Str32) : OSErr;
function NlDeregister : OSErr;

{$ENDC}

{ Initialization. Call NlInit before using any of the other functions in this unit. }

function NlInit : OSErr;

{ this function is obsolete and should no longer be used.
function NlExit : OSErr;
}

{$SETC UsingIncludes:=NetWorkLookupIncludes}
{$ENDC}

implementation

{$R-} { we are indexing dynamic arrays outside of their declared limits }

{    =============================================================    }

{    name lookup - identication of possible partners }

const

    AppletalkTransportID = 'NetA';
{$IFC NlClient}
    NlNEntities = 20;            { preallocate buffer space for # entities }
    NlReserve    = 3;            { always allow for three more entries than we
                                    already know about }

    NlTimeOut = 2*60*60;        { 2 minutes }
    NlUnused = 0;

type
    NlRecord = record
        Address : longint;
        Ticks : longint;        { last successful lookup }
(*        SystemFlag : longint;   { reserved. capas flag word}
        nProcessor : longint;   { reserved. additional processors, if any. low=count, high=quality}
*)
    end;

    NlArray        = array [1..1] of NlRecord; { dynamically sized }
    NlPtr        = ^NlArray;
    NlHandle    = ^NlPtr;

var
    NlEntityName : EntityName;    { entity to search for }
    Nlnbppb : MPPParamBlock;    { lookup parameter block }
    NlTicks : longint;            { ticks of last nltask }
    NlBuffer : Ptr;                { replies we got } { Ptr (-1) if Nl cannot be used }
    NlnbpIndex : integer;        { the reply we looked at last }
    NlElements : integer;        { number of elements in list - including 0s }
    NlStarted : longint;        { start of lookup process in ticks }
    NlNames        : NlHandle;        { points to array of partners - NIL if NL task not active }
    NlNodeCache : longint;        { avoid calls to driver }
{$ENDC}

{$IFC NlServer}
var
    NlNTE : NamesTableEntry;
    NlNTEUsed : boolean;
{$ENDC}

{    =============================================================    }

{    name lookup - identication of possible partners }

{ this function returns 0 if appletalk is down or driver/appletalk transport not installed }

function NlNode : longint;
var i, err : integer; p : TransportPtr;
begin
    i := 0;
    repeat
        err := GetTransport (p, i); i := i + 1;
    until (err <> noErr) | (p^.TransportID = longint (AppletalkTransportID));
    if err = noErr then NlNode := p^.TransportAddr
    else NlNode := 0;
end;

{$IFC NlServer}

function NlRegister (NlName, NlType : Str32) : OSErr;
var lappb : MPPParamBlock; a : longint;
begin
    a := NlNode;
    if (a = 0) then NlRegister := nlAtkOffErr
    else if NlNTEUsed then NlRegister := NlDupReg
    else begin
        if length (NlName) = 0 then NlName := GetString (-16096)^^;
        NBPSetNTE (@NlNTE, NlName, NlType, '*', BAnd (a, $000000ff));
        with lappb do begin
            verifyFlag := 0; { don't check for duplicates -- should we ? }
            entityPtr := @NlNTE;
        end;
        NlRegister := PRegisterName(@lappb, false);
        NlNTEUsed := true;
    end;
end;

function NlDeregister : OSErr;
var lappb : MPPParamBlock;
begin
{    if NlNode = 0 then NlDeRegister := nlTaskErr
    else begin -- appletalk close will have removed the name, but remove it anyway... }{ }
        with lappb do begin
            entityPtr := @NlNTE.nteData [2];
        end;
        if NlNTEUsed then
            NlDeregister := PRemoveName(@lappb, false)
        else NlDeregister := nlNoReg;
        NlNTEUsed := false;
end;
{$ENDC}

{$IFC NlClient}
function NlSetSearch (NlName, NlType, NlZone : Str32) : OSErr;
begin
    if (NlNames <> nil) then NlSetSearch := nlTaskErr { lookup task active }
    else begin
        NlSetSearch := noErr;
        NBPSetEntity(@NlEntityName, NlName, NlType, NlZone);
    end;
end;

function NbpStart (entitycount : integer) : OSErr;
var buffsize : longint;
begin
    NlNodeCache := NlNode;
    buffsize := sizeof (NamesTableEntry) * (entitycount + NLReserve);
    NlBuffer := NewPtr (buffsize);
    if NlBuffer = nil then NbpStart := MemError
    else begin
        with Nlnbppb do begin
            ioCompletion := nil;
            if NlStarted - TickCount < 180 then
                interval := 20    { 20 seconds interval }
            else
                interval := 60; { 60 seconds interval }
            count := 1;     { retries done separateley }
            entityPtr := @NlEntityName;
            retBuffPtr := NlBuffer;
            retBuffSize := buffsize;
            maxToGet := entitycount;{ approx responses - should be maxint }
        end;
        NbpStart := PLookUpName (@Nlnbppb, true);
    end;
end;

function NbpStop : OSErr;
var buffsize : longint; nbppb : MPPParamBlock; err : integer;
begin
    NbpStop := noErr;
    if NlNbppb.ioresult > 0 then begin
        with nbppb do nKillQEl := @NlNbppb;
        err := PKillNBP (@nbppb, false);
        if err = controlErr then { cannot abort, must wait for completion - appletalk version < 48 }
            repeat
                err := NlNbppb.ioresult;
            until err <= noErr;
        NbpStop := err;
    end;
    DisposPtr (NlBuffer); NlBuffer := nil;
end;

function NlStart : OSErr;
var err : OSErr;
    mppdce : DCtlHandle;
begin
    if (NlBuffer <> nil) then NlStart := nlTaskErr { already active }
    else begin
        err := ATPLoad; { ignore error }
    (*    mppdce := GetDCtlEntry (-10); { .MPP }
        if (mppdce = nil) | (Ptr (longint (@mppdce^^.dCtlQHdr) +1)^ < 48) then
            err := nlVersion
        else *) begin
            NlnbpIndex := 1; NlStarted := TickCount; NlElements := 0;
            NlNames := NlHandle (NewHandleClear (sizeof (NlRecord) * NlNEntities));
            if NlNames = nil then err := MemError
            else begin
                err := NbpStart (NlNEntities);
                if err = notOpenErr then
                    err := noErr; { automatically restarted when AppleTalk is turned on }
            end;
        end;
    end;
    if err < 0 then NlStart := err else NlStart := noErr; { compensate for A/UX returning 1 }
end;

function NlStop : OSErr;
var err : integer;
begin
    if (NlBuffer = nil) then err := nlTaskErr { not active }
    else begin
        err := NbpStop; NlElements := nlTaskErr;
        DisposHandle (Handle (NlNames)); NlNames := nil;
    end;
    NlStop := err;
end;

function NlGetSleep : longint;
var sleep : longint;
begin
    if (NlBuffer = nil) then sleep := maxlongint { no time required at all }
    else sleep := NlTicks + 300 - TickCount; { once every five seconds is always enough }
    if sleep < 0 then sleep := 0;
    NlGetSleep := sleep;
end;

{    NlTask updates the information in NlNames based upon responses to the
    most recent async name lookup. If the name lookup timed out, a new is
    initiated. The ticks valus in names is updated for all entities found.
    If new entities are found, they replace records with an address of 0.
    If new entries are found, the handle is enlarged. Call this routine
    during idle time or whenever new entities may be useful. }

function NlTask : OSErr;

var err : OSErr;
    entity : EntityName;
    a : AddrBlock;
    p, q : NlPtr; i, n : integer;
    l : longint;
begin
    if (NlBuffer = nil) then err := noErr
    else if (NlBuffer = Ptr (-1)) then err := nlTaskErr
    else begin
        NlTicks := TickCount; err := noErr;
        while (err = noErr) and (NlnbpIndex <= NlNbppb.numGotten) do
        if not IsMPPOpen then begin
            NlNbpPb.ioresult := notOpenErr;
            err := NbpStop
        end
        else begin
            err := NBPExtract (NlBuffer, NlNbppb.numGotten, NlnbpIndex, entity, a);
            if err <> noErr then CheckError ('NBPExtract returned error', err) { never }
            else begin
                NlnbpIndex := NlnbpIndex + 1;
                if longint (a) <> NlNodeCache then begin { don't include ourself in list }
                    n := NlElements; p := NlNames^; q := nil;
                    while n > 0 do begin
                        if longint (p^[n].Address) = longint (a) then n := -1 { stop search }
                        else n := n - 1;
                    end;
                    if n = 0 then begin{ not found, add }
                        l := GetHandleSize (Handle (NlNames)); n := l div sizeof (NlRecord);
                        if n <= NlElements then begin
                            SetHandleSize (Handle (NlNames), l + sizeof (NlRecord) * NlReserve);
                            err := MemError;
                        end;
                        if err = noErr then begin { avail position at end of list }
                            NlElements := NlElements + 1;
                            with NlNames^^ [NlElements] do begin
                                Address := longint (a); Ticks := NlTicks;
                            end
                        end;
                    end;
                end;
            end;
        end;
        { while (err = noErr) and (NlnbpIndex <= NlNbppb.nbpDataField) do  }

        if (err = noErr) and (NlNbpPb.ioresult <= 0) then begin { restart }
            err := NbpStop; NlnbpIndex := 1;
            n := NlElements;
            if n < NlNEntities then n := NlNEntities;
            if err = noErr then err := NbpStart (n);

            l := NlTicks - NlTimeout;            { added 21-10-89 , modified 31-10-89 }
            n := 1; i := 1; p := NlNames^;        { note that we preserve order to allow }
            while n <= NlElements do            { round robin fashion }
            with p^ [n] do
            if Ticks < l then n := n + 1 { skip, don´t copy }
            else begin
                if i <> n then p^[i] := p^[n];
                i := i + 1; n := n + 1;
            end;
            NlElements := i - 1;
        end;
    end;
    NlTask := err;
end;

function NlCount : integer;
var i, n : integer; l : longint;
    p : NlPtr;
begin
    NlCount := NlElements;
end;

function NlIndex (address : longint) : integer; { or OSErr, if error }
var n : integer;
    p : NlPtr;
begin
    if NlNames = nil then NlIndex := nlTaskErr
    else begin
        n := NlElements; p := NlNames^;
        while (n > 0) & (p^[n].Address <> address) do n := n - 1;
        if n = 0 then NlIndex := nlNotFound
        else NlIndex := n;
    end
end;

function NLActive(who:longint):boolean;
var scr:integer;
begin
    NLActive:=false; {default}
     if NlCount>0 then begin
     NLActive:=(NLIndex(who)>0);
     end;
end;

{    random questionable, because the modulus may change }

function NLRandom:longint;
var NrOthers,scr1:integer;
begin
    scr1 := NlTask; { update table }
    NrOthers := NlElements;
    if NrOthers < 1 then NLRandom:=0 else begin
        scr1:=abs(random mod NrOthers) + 1;
        {•••••••• random uses a5 ••••••••••••••••••}
        NLRandom:=NlNames^^[scr1].Address;
    end;
end;

{    this function could be improved to cache the last index }

function NLNext(after:longint):longint;
var scr,NrOthers:integer;
begin
    scr := NlTask; { update table }
    NrOthers:=NlElements;
    if after=0 then scr:=1 else scr:=NLindex(after)+1;
    if (NrOthers < 1) or (scr<0) then NLNext:=0 else begin
        if scr>NrOthers then scr:=1;
        NLNext:= NlNames^^[scr].Address;
    end;
end;
{$ENDC}

{    =============================================================    }

{    event patch }

{$Z+} {export symbols}

function EventPatch (var ev : EventRecord) : boolean;
var err : integer; saveda5 : longint;
begin
    saveda5 := SetCurrentA5;
{$IFC NlClient}
    if NlNames <> nil then err := NlTask;
{$ENDC}
    savedA5 := SetA5 (savedA5);
end;
{$Z-} {export symbols}

{    =============================================================    }

{    initialization and termination }

procedure InstallPatches;
external;
procedure UnInstallPatches;
external;


function NlExit : OSErr;
begin
    NlExit := noErr;
{$IFC NlClient}
    if Nlbuffer <> nil then CheckError ('ExitNameLookup', NlStop);
{$ENDC}
{$IFC NlServer}
    if NlNTEUsed then CheckError ('NlDeregister', NlDeregister);
{$ENDC}
    UninstallPatches;
end;

{$Z+} {export symbols}
procedure ExitPatch;
var e : integer; saveda5 : longint;
begin
    saveda5 := SetCurrentA5;
    e := NlExit;
    savedA5 := SetA5 (savedA5);
end;
{$Z-} {export symbols}

function NlInit : OSErr;
begin
    NlInit := noErr;
    InstallPatches;
{$IFC NlServer}
    NlNTEUsed := false;
{$ENDC}
{$IFC NlClient}
    NlNames := nil; NlBuffer := nil; NlElements := nlTaskErr;
    CheckError ('set search', NlSetSearch ('=', 'Network Processor', '*'));
{$ENDC}
end;

end.